home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / prim.c < prev    next >
C/C++ Source or Header  |  1992-10-27  |  22KB  |  396 lines
  1. /* Build-in primitives, Define_Primitive
  2.  */
  3.  
  4. #include "scheme.h"
  5.  
  6. struct Prim_Init {
  7.     Object (*fun)();
  8.     char *name;
  9.     int minargs, maxargs;
  10.     enum discipline disc;
  11. } Primitives[] = {
  12.  
  13.     /* autoload.c:
  14.      */
  15.     P_Autoload,          "autoload",                       2, 2,    EVAL,
  16.  
  17.     /* bool.c:
  18.      */
  19.     P_Booleanp,          "boolean?",                       1, 1,    EVAL,
  20.     P_Not,               "not",                            1, 1,    EVAL,
  21.     P_Eq,                "eq?",                            2, 2,    EVAL,
  22.     P_Eqv,               "eqv?",                           2, 2,    EVAL,
  23.     P_Equal,             "equal?",                         2, 2,    EVAL,
  24.  
  25.     /* char.c:
  26.      */
  27.     P_Charp,             "char?",                          1, 1,    EVAL,
  28.     P_Char_To_Integer,   "char->integer",                  1, 1,    EVAL,
  29.     P_Integer_To_Char,   "integer->char",                  1, 1,    EVAL,
  30.     P_Char_Upper_Case,   "char-upper-case?",               1, 1,    EVAL,
  31.     P_Char_Lower_Case,   "char-lower-case?",               1, 1,    EVAL,
  32.     P_Char_Alphabetic,   "char-alphabetic?",               1, 1,    EVAL,
  33.     P_Char_Numeric,      "char-numeric?",                  1, 1,    EVAL,
  34.     P_Char_Whitespace,   "char-whitespace?",               1, 1,    EVAL,
  35.     P_Char_Upcase,       "char-upcase",                    1, 1,    EVAL,
  36.     P_Char_Downcase,     "char-downcase",                  1, 1,    EVAL,
  37.     P_Chr_Eq,            "char=?",                         2, 2,    EVAL,
  38.     P_Chr_Less,          "char<?",                         2, 2,    EVAL,
  39.     P_Chr_Greater,       "char>?",                         2, 2,    EVAL,
  40.     P_Chr_Eq_Less,       "char<=?",                        2, 2,    EVAL,
  41.     P_Chr_Eq_Greater,    "char>=?",                        2, 2,    EVAL,
  42.     P_Chr_CI_Eq,         "char-ci=?",                      2, 2,    EVAL,
  43.     P_Chr_CI_Less,       "char-ci<?",                      2, 2,    EVAL,
  44.     P_Chr_CI_Greater,    "char-ci>?",                      2, 2,    EVAL,
  45.     P_Chr_CI_Eq_Less,    "char-ci<=?",                     2, 2,    EVAL,
  46.     P_Chr_CI_Eq_Greater, "char-ci>=?",                     2, 2,    EVAL,
  47.  
  48.     /* cont.c:
  49.      */
  50.     P_Control_Pointp,    "control-point?",                 1, 1,    EVAL,
  51.     P_Call_CC,           "call-with-current-continuation", 1, 1,    EVAL,
  52.     P_Dynamic_Wind,      "dynamic-wind",                   3, 3,    EVAL,
  53.     P_Control_Point_Env, "control-point-environment",      1, 1,    EVAL,
  54.  
  55.     /* debug.c:
  56.      */
  57.     P_Backtrace_List,    "backtrace-list",                 0, 1,    VARARGS,
  58.  
  59.     /* dump.c:
  60.      */
  61. #ifdef CAN_DUMP
  62.     P_Dump,              "dump",                           1, 1,    EVAL,
  63. #endif
  64.  
  65.     /* env.c:
  66.      */
  67.     P_Environmentp,      "environment?",                   1, 1,    EVAL,
  68.     P_The_Environment,   "the-environment",                0, 0,    EVAL,
  69.     P_Global_Environment,"global-environment",             0, 0,    EVAL,
  70.     P_Define,            "define",                         1, MANY, NOEVAL,
  71.     P_Define_Macro,      "define-macro",                   1, MANY, NOEVAL,
  72.     P_Set,               "set!",                           2, 2,    NOEVAL,
  73.     P_Env_List,          "environment->list",              1, 1,    EVAL,
  74.     P_Boundp,            "bound?",                         1, 1,    EVAL,
  75.  
  76.     /* error.c:
  77.      */
  78.     P_Error,             "error",                          2, MANY, VARARGS,
  79.     P_Reset,             "reset",                          0, 0,    EVAL,
  80.  
  81.     /* feature.c:
  82.      */
  83.     P_Featurep,          "feature?",                       1, 1,    EVAL,
  84.     P_Provide,           "provide",                        1, 1,    EVAL,
  85.     P_Require,           "require",                        1, 3,    VARARGS,
  86.  
  87.     /* heap.c:
  88.      */
  89.     P_Collect,           "collect",                        0, 0,    EVAL,
  90.  
  91.     /* io.c:
  92.      */
  93.     P_Port_File_Name,    "port-file-name",                 1, 1,    EVAL,
  94.     P_Port_Line_Number,  "port-line-number",               1, 1,    EVAL,
  95.     P_Eof_Objectp,       "eof-object?",                    1, 1,    EVAL,
  96.     P_Curr_Input_Port,   "current-input-port",             0, 0,    EVAL,
  97.     P_Curr_Output_Port,  "current-output-port",            0, 0,    EVAL,
  98.     P_Input_Portp,       "input-port?",                    1, 1,    EVAL,
  99.     P_Output_Portp,      "output-port?",                   1, 1,    EVAL,
  100.     P_Open_Input_File,   "open-input-file",                1, 1,    EVAL,
  101.     P_Open_Output_File,  "open-output-file",               1, 1,    EVAL,
  102.     P_Open_Input_Output_File, "open-input-output-file",    1, 1,    EVAL,
  103.     P_Close_Input_Port,  "close-input-port",               1, 1,    EVAL,
  104.     P_Close_Output_Port, "close-output-port",              1, 1,    EVAL,
  105.     P_With_Input,        "with-input-from-file",           2, 2,    EVAL,
  106.     P_With_Output,       "with-output-to-file",            2, 2,    EVAL,
  107.     P_Call_With_Input,   "call-with-input-file",           2, 2,    EVAL,
  108.     P_Call_With_Output,  "call-with-output-file",          2, 2,    EVAL,
  109.     P_Open_Input_String, "open-input-string",              1, 1,    EVAL,
  110.     P_Open_Output_String,"open-output-string",             0, 0,    EVAL,
  111.     P_Tilde_Expand,      "tilde-expand",                   1, 1,    EVAL,
  112.     P_File_Existsp,      "file-exists?",                   1, 1,    EVAL,
  113.  
  114.     /* load.c:
  115.      */
  116.     P_Load,              "load",                           1, 2,    VARARGS,
  117.  
  118.     /* list.c:
  119.      */
  120.     P_Cons,              "cons",                           2, 2,    EVAL,
  121.     P_Car,               "car",                            1, 1,    EVAL,
  122.     P_Cdr,               "cdr",                            1, 1,    EVAL,
  123.     P_Caar,              "caar",                           1, 1,    EVAL,
  124.     P_Cadr,              "cadr",                           1, 1,    EVAL,
  125.     P_Cdar,              "cdar",                           1, 1,    EVAL,
  126.     P_Cddr,              "cddr",                           1, 1,    EVAL,
  127.  
  128.     P_Caaar,             "caaar",                          1, 1,    EVAL,
  129.     P_Caadr,             "caadr",                          1, 1,    EVAL,
  130.     P_Cadar,             "cadar",                          1, 1,    EVAL,
  131.     P_Caddr,             "caddr",                          1, 1,    EVAL,
  132.     P_Cdaar,             "cdaar",                          1, 1,    EVAL,
  133.     P_Cdadr,             "cdadr",                          1, 1,    EVAL,
  134.     P_Cddar,             "cddar",                          1, 1,    EVAL,
  135.     P_Cdddr,             "cdddr",                          1, 1,    EVAL,
  136.  
  137.     P_Caaaar,            "caaaar",                         1, 1,    EVAL,
  138.     P_Caaadr,            "caaadr",                         1, 1,    EVAL,
  139.     P_Caadar,            "caadar",                         1, 1,    EVAL,
  140.     P_Caaddr,            "caaddr",                         1, 1,    EVAL,
  141.     P_Cadaar,            "cadaar",                         1, 1,    EVAL,
  142.     P_Cadadr,            "cadadr",                         1, 1,    EVAL,
  143.     P_Caddar,            "caddar",                         1, 1,    EVAL,
  144.     P_Cadddr,            "cadddr",                         1, 1,    EVAL,
  145.     P_Cdaaar,            "cdaaar",                         1, 1,    EVAL,
  146.     P_Cdaadr,            "cdaadr",                         1, 1,    EVAL,
  147.     P_Cdadar,            "cdadar",                         1, 1,    EVAL,
  148.     P_Cdaddr,            "cdaddr",                         1, 1,    EVAL,
  149.     P_Cddaar,            "cddaar",                         1, 1,    EVAL,
  150.     P_Cddadr,            "cddadr",                         1, 1,    EVAL,
  151.     P_Cdddar,            "cdddar",                         1, 1,    EVAL,
  152.     P_Cddddr,            "cddddr",                         1, 1,    EVAL,
  153.  
  154.     P_Cxr,               "cxr",                            2, 2,    EVAL,
  155.     P_Nullp,             "null?",                          1, 1,    EVAL,
  156.     P_Pairp,             "pair?",                          1, 1,    EVAL,
  157.     P_Listp,             "list?",                          1, 1,    EVAL,
  158.     P_Setcar,            "set-car!",                       2, 2,    EVAL,
  159.     P_Setcdr,            "set-cdr!",                       2, 2,    EVAL,
  160.     P_Assq,              "assq",                           2, 2,    EVAL,
  161.     P_Assv,              "assv",                           2, 2,    EVAL,
  162.     P_Assoc,             "assoc",                          2, 2,    EVAL,
  163.     P_Memq,              "memq",                           2, 2,    EVAL,
  164.     P_Memv,              "memv",                           2, 2,    EVAL,
  165.     P_Member,            "member",                         2, 2,    EVAL,
  166.     P_Make_List,         "make-list",                      2, 2,    EVAL,
  167.     P_List,              "list",                           0, MANY, VARARGS,
  168.     P_Length,            "length",                         1, 1,    EVAL,
  169.     P_Append,            "append",                         0, MANY, VARARGS,
  170.     P_Append_Set,        "append!",                        0, MANY, VARARGS,
  171.     P_Last_Pair,         "last-pair",                      1, 1,    EVAL,
  172.     P_Reverse,           "reverse",                        1, 1,    EVAL,
  173.     P_Reverse_Set,       "reverse!",                       1, 1,    EVAL,
  174.     P_List_Tail,         "list-tail",                      2, 2,    EVAL,
  175.     P_List_Ref,          "list-ref",                       2, 2,    EVAL,
  176.  
  177.     /* main.c:
  178.      */
  179.     P_Command_Line_Args, "command-line-args",              0, 0,    EVAL,
  180.     P_Exit,              "exit",                           0, 1,    VARARGS,
  181.  
  182.     /* math.c:
  183.      */
  184.     P_Number_To_String,  "number->string",                 1, 2,    VARARGS,
  185.     P_Numberp,           "number?",                        1, 1,    EVAL,
  186.     P_Complexp,          "complex?",                       1, 1,    EVAL,
  187.     P_Realp,             "real?",                          1, 1,    EVAL,
  188.     P_Rationalp,         "rational?",                      1, 1,    EVAL,
  189.     P_Integerp,          "integer?",                       1, 1,    EVAL,
  190.     P_Zerop,             "zero?",                          1, 1,    EVAL,
  191.     P_Positivep,         "positive?",                      1, 1,    EVAL,
  192.     P_Negativep,         "negative?",                      1, 1,    EVAL,
  193.     P_Oddp,              "odd?",                           1, 1,    EVAL,
  194.     P_Evenp,             "even?",                          1, 1,    EVAL,
  195.     P_Exactp,            "exact?",                         1, 1,    EVAL,
  196.     P_Inexactp,          "inexact?",                       1, 1,    EVAL,
  197.     P_Generic_Less,      "<",                              1, MANY, VARARGS,
  198.     P_Generic_Greater,   ">",                              1, MANY, VARARGS,
  199.     P_Generic_Equal,     "=",                              1, MANY, VARARGS,
  200.     P_Generic_Eq_Less,   "<=",                             1, MANY, VARARGS,
  201.     P_Generic_Eq_Greater,">=",                             1, MANY, VARARGS,
  202.     P_Inc,               "1+",                             1, 1,    EVAL,
  203.     P_Dec,               "-1+",                            1, 1,    EVAL,
  204.     P_Dec,               "1-",                             1, 1,    EVAL,
  205.     P_Generic_Plus,      "+",                              0, MANY, VARARGS,
  206.     P_Generic_Minus,     "-",                              1, MANY, VARARGS,
  207.     P_Generic_Multiply,  "*",                              0, MANY, VARARGS,
  208.     P_Generic_Divide,    "/",                              1, MANY, VARARGS,
  209.     P_Abs,               "abs",                            1, 1,    EVAL,
  210.     P_Quotient,          "quotient",                       2, 2,    EVAL,
  211.     P_Remainder,         "remainder",                      2, 2,    EVAL,
  212.     P_Modulo,            "modulo",                         2, 2,    EVAL,
  213.     P_Gcd,               "gcd",                            0, MANY, VARARGS,
  214.     P_Lcm,               "lcm",                            0, MANY, VARARGS,
  215.     P_Floor,             "floor",                          1, 1,    EVAL,
  216.     P_Ceiling,           "ceiling",                        1, 1,    EVAL,
  217.     P_Truncate,          "truncate",                       1, 1,    EVAL,
  218.     P_Round,             "round",                          1, 1,    EVAL,
  219.     P_Sqrt,              "sqrt",                           1, 1,    EVAL,
  220.     P_Exp,               "exp",                            1, 1,    EVAL,
  221.     P_Log,               "log",                            1, 1,    EVAL,
  222.     P_Sin,               "sin",                            1, 1,    EVAL,
  223.     P_Cos,               "cos",                            1, 1,    EVAL,
  224.     P_Tan,               "tan",                            1, 1,    EVAL,
  225.     P_Asin,              "asin",                           1, 1,    EVAL,
  226.     P_Acos,              "acos",                           1, 1,    EVAL,
  227.     P_Atan,              "atan",                           1, 2,    VARARGS,
  228.     P_Min,               "min",                            1, MANY, VARARGS,
  229.     P_Max,               "max",                            1, MANY, VARARGS,
  230.     P_Random,            "random",                         0, 0,    EVAL,
  231.     P_Srandom,           "srandom",                        1, 1,    EVAL,
  232.  
  233.     /* prim.c:
  234.      */
  235.  
  236.     /* print.c:
  237.      */
  238.     P_Write,             "write",                          1, 2,    VARARGS,
  239.     P_Display,           "display",                        1, 2,    VARARGS,
  240.     P_Write_Char,        "write-char",                     1, 2,    VARARGS,
  241.     P_Newline,           "newline",                        0, 1,    VARARGS,
  242.     P_Print,             "print",                          1, 2,    VARARGS,
  243.     P_Clear_Output_Port, "clear-output-port",              0, 1,    VARARGS,
  244.     P_Flush_Output_Port, "flush-output-port",              0, 1,    VARARGS,
  245.     P_Get_Output_String, "get-output-string",              1, 1,    EVAL,
  246.     P_Format,            "format",                         2, MANY, VARARGS,
  247.  
  248.     /* proc.c:
  249.      */
  250.     P_Procedurep,        "procedure?",                     1, 1,    EVAL,
  251.     P_Primitivep,        "primitive?",                     1, 1,    EVAL,
  252.     P_Compoundp,         "compound?",                      1, 1,    EVAL,
  253.     P_Macrop,            "macro?",                         1, 1,    EVAL,
  254.     P_Eval,              "eval",                           1, 2,    VARARGS,
  255.     P_Apply,             "apply",                          2, MANY, VARARGS,
  256.     P_Lambda,            "lambda",                         2, MANY, NOEVAL,
  257.     P_Procedure_Env,     "procedure-environment",          1, 1,    EVAL,
  258.     P_Procedure_Lambda,  "procedure-lambda",               1, 1,    EVAL,
  259.     P_Map,               "map",                            2, MANY, VARARGS,
  260.     P_For_Each,          "for-each",                       2, MANY, VARARGS,
  261.     P_Macro,             "macro",                          2, MANY, NOEVAL,
  262.     P_Macro_Body,        "macro-body",                     1, 1,    EVAL,
  263.     P_Macro_Expand,      "macro-expand",                   1, 1,    EVAL,
  264.  
  265.     /* promise.c:
  266.      */
  267.     P_Delay,             "delay",                          1, 1,    NOEVAL,
  268.     P_Force,             "force",                          1, 1,    EVAL,
  269.     P_Promisep,          "promise?",                       1, 1,    EVAL,
  270.     P_Promise_Env,       "promise-environment",            1, 1,    EVAL,
  271.  
  272.     /* read.c:
  273.      */
  274.     P_Clear_Input_Port,  "clear-input-port",               0, 1,    EVAL,
  275.     P_Read,              "read",                           0, 1,    VARARGS,
  276.     P_Read_Char,         "read-char",                      0, 1,    VARARGS,
  277.     P_Read_String,       "read-string",                    0, 1,    VARARGS,
  278.     P_Unread_Char,       "unread-char",                    1, 2,    VARARGS,
  279.     P_Peek_Char,         "peek-char",                      0, 1,    VARARGS,
  280.  
  281.     /* special.c:
  282.      */
  283.     P_Quote,             "quote",                          1, 1,    NOEVAL,
  284.     P_Quasiquote,        "quasiquote",                     1, 1,    NOEVAL,
  285.     P_Begin,             "begin",                          1, MANY, NOEVAL,
  286.     P_Begin1,            "begin1",                         1, MANY, NOEVAL,
  287.     P_If,                "if",                             2, MANY, NOEVAL,
  288.     P_Case,              "case",                           2, MANY, NOEVAL,
  289.     P_Cond,              "cond",                           1, MANY, NOEVAL,
  290.     P_Do,                "do",                             2, MANY, NOEVAL,
  291.     P_Let,               "let",                            2, MANY, NOEVAL,
  292.     P_Letseq,            "let*",                           2, MANY, NOEVAL,
  293.     P_Letrec,            "letrec",                         2, MANY, NOEVAL,
  294.     P_Fluid_Let,         "fluid-let",                      2, MANY, NOEVAL,
  295.     P_And,               "and",                            0, MANY, NOEVAL,
  296.     P_Or,                "or",                             0, MANY, NOEVAL,
  297.  
  298.     /* string.c:
  299.      */
  300.     P_String,            "string",                         0, MANY, VARARGS,
  301.     P_Stringp,           "string?",                        1, 1,    EVAL,
  302.     P_Make_String,       "make-string",                    1, 2,    VARARGS,
  303.     P_String_Length,     "string-length",                  1, 1,    EVAL,
  304.     P_String_To_Number,  "string->number",                 1, 2,    VARARGS,
  305.     P_String_Ref,        "string-ref",                     2, 2,    EVAL,
  306.     P_String_Set,        "string-set!",                    3, 3,    EVAL,
  307.     P_Substring,         "substring",                      3, 3,    EVAL,
  308.     P_String_Copy,       "string-copy",                    1, 1,    EVAL,
  309.     P_String_Append,     "string-append",                  0, MANY, VARARGS,
  310.     P_List_To_String,    "list->string",                   1, 1,    EVAL,
  311.     P_String_To_List,    "string->list",                   1, 1,    EVAL,
  312.     P_String_Fill,       "string-fill!",                   2, 2,    EVAL,
  313.     P_Substring_Fill,    "substring-fill!",                4, 4,    EVAL,
  314.     P_Str_Eq,            "string=?",                       2, 2,    EVAL,
  315.     P_Str_Less,          "string<?",                       2, 2,    EVAL,
  316.     P_Str_Greater,       "string>?",                       2, 2,    EVAL,
  317.     P_Str_Eq_Less,       "string<=?",                      2, 2,    EVAL,
  318.     P_Str_Eq_Greater,    "string>=?",                      2, 2,    EVAL,
  319.     P_Str_CI_Eq,         "string-ci=?",                    2, 2,    EVAL,
  320.     P_Str_CI_Less,       "string-ci<?",                    2, 2,    EVAL,
  321.     P_Str_CI_Greater,    "string-ci>?",                    2, 2,    EVAL,
  322.     P_Str_CI_Eq_Less,    "string-ci<=?",                   2, 2,    EVAL,
  323.     P_Str_CI_Eq_Greater, "string-ci>=?",                   2, 2,    EVAL,
  324.     P_Substringp,        "substring?",                     2, 2,    EVAL,
  325.     P_CI_Substringp,     "substring-ci?",                  2, 2,    EVAL,
  326.  
  327.     /* symbol.c:
  328.      */
  329.     P_String_To_Symbol,  "string->symbol",                 1, 1,    EVAL,
  330.     P_Oblist,            "oblist",                         0, 0,    EVAL,
  331.     P_Symbolp,           "symbol?",                        1, 1,    EVAL,
  332.     P_Symbol_To_String,  "symbol->string",                 1, 1,    EVAL,
  333.     P_Put,               "put",                            2, 3,    VARARGS,
  334.     P_Get,               "get",                            2, 2,    EVAL,
  335.     P_Symbol_Plist,      "symbol-plist",                   1, 1,    EVAL,
  336.  
  337.     /* type.c:
  338.      */
  339.     P_Type,              "type",                           1, 1,    EVAL,
  340.     P_Voidp,             "void?",                          1, 1,    EVAL,
  341.  
  342.     /* vector.c:
  343.      */
  344.     P_Vectorp,           "vector?",                        1, 1,    EVAL,
  345.     P_Make_Vector,       "make-vector",                    1, 2,    VARARGS,
  346.     P_Vector,            "vector",                         0, MANY, VARARGS,
  347.     P_Vector_Length,     "vector-length",                  1, 1,    EVAL,
  348.     P_Vector_Ref,        "vector-ref",                     2, 2,    EVAL,
  349.     P_Vector_Set,        "vector-set!",                    3, 3,    EVAL,
  350.     P_Vector_To_List,    "vector->list",                   1, 1,    EVAL,
  351.     P_List_To_Vector,    "list->vector",                   1, 1,    EVAL,
  352.     P_Vector_Fill,       "vector-fill!",                   2, 2,    EVAL,
  353.     P_Vector_Copy,       "vector-copy",                    1, 1,    EVAL,
  354.  
  355.     0
  356. };
  357.  
  358. /* The C-compiler can't initialize unions, thus the primitive procedures
  359.  * must be created during run-time (the problem actually is that one can't
  360.  * provide an intializer for the "tag" component of an S_Primitive).
  361.  */
  362.  
  363. Init_Prim () {
  364.     register struct Prim_Init *p;
  365.     Object frame, prim, sym;
  366.  
  367.     for (frame = Car (The_Environment), p = Primitives; p->fun; p++) {
  368.     prim = Make_Primitive (p->fun, p->name, p->minargs, p->maxargs,
  369.         p->disc);
  370.     sym = Intern (p->name);
  371.     frame = Add_Binding (frame, sym, prim);
  372.     }
  373.     Car (The_Environment) = frame;
  374.     Memoize_Frame (frame);
  375. }
  376.  
  377. /* Not used by the interpreter kernel (lint may complain).
  378.  */
  379. Define_Primitive (fun, name, min, max, disc) Object (*fun)(); char *name;
  380.     enum discipline disc; {
  381.     Object prim, sym, frame;
  382.     GC_Node2;
  383.  
  384.     Error_Tag = "define-primitive";
  385.     prim = Make_Primitive (fun, name, min, max, disc);
  386.     sym = Null;
  387.     GC_Link2 (prim, sym);
  388.     sym = Intern (name);
  389.     if (disc == EVAL && min != max)
  390.     Primitive_Error ("~s: number of arguments must be fixed", sym);
  391.     frame = Add_Binding (Car (The_Environment), sym, prim);
  392.     SYMBOL(sym)->value = prim;
  393.     Car (The_Environment) = frame;
  394.     GC_Unlink;
  395. }
  396.